(FILECREATED " 7-NOV-73  5:24:38" S-GENLISP)


  (LISPXPRINT (QUOTE GENLISPVARS)
              T)
  (RPAQQ GENLISPVARS
         ((* VERY GENERAL PURPOSE ROUTINES
             (BUT NOT SYSTEM INTERFACE ROUTINES; I.E. DON'T DEPEND ON 
                  VAGARIES OF LISP FILE PACKAGE, FOR EXAMPLE))
          (FNS GROUPRADS GROUPRADS1 CIELING GROUPBY CARLIST CDRLIST 
               LCARLIST LCDRLIST DELETE DIFF ORDPAIR MAX MIN ORDERED 
               SUMOF LMASSOC INTERSECTP ?=)
          (BLOCKS (GROUPRADBLOCK GROUPRADS GROUPRADS1 (ENTRIES 
                                                        GROUPRADS))
                  (NIL CIELING GROUPBY CARLIST CDRLIST LCARLIST 
                       LCDRLIST DELETE DIFF ORDPAIR MAX MIN ORDERED 
                       SUMOF LMASSOC INTERSECTP ?= (LINKFNS . T)))
          (USERMACROS ?=)))

(* VERY GENERAL PURPOSE ROUTINES (BUT NOT SYSTEM INTERFACE ROUTINES;
I.E. DON'T DEPEND ON VAGARIES OF LISP FILE PACKAGE, FOR EXAMPLE))

(DEFINEQ

(GROUPRADS
  [LAMBDA (CLOFLISTS)

          (* Takes a composition list of lists and returns 
          all the list of all possible selections;
          with one from each list; for example given 
          (((A B C) . 2) ((E F) . 3)) returns 
          (A A E E E) (A A E E F) (A A E F E) ...
          I.e. All lists with 2 elements from 
          (A B C) and three from (E F) 
          (duplication allowed))


    (COND
      ((NULL CLOFLISTS)
        (LIST NIL))
      (T (GROUPRADS1 (CAAR CLOFLISTS)
                     (CDAR CLOFLISTS)
                     (GROUPRADS (CDR CLOFLISTS])

(GROUPRADS1
  [LAMBDA (TAKELIST N LISTSDONE)
    (COND
      ((ZEROP N)
        LISTSDONE)
      (T (FOR OLD TAKELIST ON TAKELIST FOR RADS
            IN (GROUPRADS1 TAKELIST (SUB1 N)
                           LISTSDONE)
            COLLECT (CONS (CAR TAKELIST)
                          RADS])

(CIELING
  [LAMBDA (X)
    (FIX (PLUS X .99])

(GROUPBY
  [LAMBDA (FN L)

          (* FN is a function of one argument;
          L is a list; returns L grouped by the values of FN 
          applied to it; e.g. (GROUPBY 'VALENCE L) will 
          return ((2 %. Atoms with VALENCE 2) 
          (3 %. Atoms with VALENCE 3) ...))


    (COND
      ((NULL L)
        NIL)
      (T (PROG (FNX GROUPCDR X)
               (SETQ GROUPCDR (GROUPBY FN (CDR L)))
               (COND
                 ((NULL (SETQ X (LMASSOC (SETQ FNX
                                           (APPLY* FN (CAR L)))
                                         GROUPCDR NIL)))
                   (RETURN (CONS (LIST FNX (CAR L))
                                 GROUPCDR)))
                 (T (NCONC1 X (CAR L))
                    (RETURN GROUPCDR])

(CARLIST
  [LAMBDA (L)
    (for X in L collect (CAR X])

(CDRLIST
  [LAMBDA (L)
    (for X in L collect (CDR X])

(LCARLIST
  [LAMBDA (L)
    (for X in L collect (CARLIST X])

(LCDRLIST
  [LAMBDA (L)
    (for X in L collect (CDRLIST X])

(DELETE
  [LAMBDA (I L)
    (COND
      [(NULL L)
        (HELP (QUOTE (BAD ARG TO DELETE]
      ((EQ (CAR L)
           I)
        (CDR L))
      (T (RPLACD L (DELETE I (CDR L])

(DIFF
  [LAMBDA (L1 L2)
    (FOR X IN L1 WHEN (NOT (MEMBER X L2)) COLLECT X])

(ORDPAIR
  [LAMBDA (X1 X2)
    (COND
      ((ORDERED X1 X2)
        (CONS X1 X2))
      (T (CONS X2 X1])

(MAX
  [LAMBDA (X Y)
    (COND
      ((IGREATERP X Y)
        X)
      (T Y])

(MIN
  [LAMBDA (X Y)
    (COND
      ((IGREATERP X Y)
        Y)
      (T X])

(ORDERED
  [LAMBDA (X Y)
    (COND
      ((NLISTP X)
        (ALPHORDER X Y))
      ((NLISTP Y)
        NIL)
      ((EQUAL (CAR X)
              (CAR Y))
        (ORDERED (CDR X)
                 (CDR Y)))
      (T (ORDERED (CAR X)
                  (CAR Y])

(SUMOF
  [LAMBDA (L)
    (for X in L sum X])

(LMASSOC
  [LAMBDA (X Y Z)
    (COND
      ([SETQ X (COND
            ((OR (SMALLP X)
                 (LITATOM X))
              (ASSOC X Y))
            (T (SASSOC X Y]
        (CDR X))
      (T Z])

(INTERSECTP
  [LAMBDA (X Y)
    (OR (NULL X)
        (NULL Y)
        (COND
          [(LISTP X)
            (SOME X (FUNCTION (LAMBDA (X)
                      (INTERSECTP X Y]
          [(LISTP Y)
            (SOME Y (FUNCTION (LAMBDA (Y)
                      (INTERSECTP X Y]
          (T (EQ X Y])

(?=
  [LAMBDA (FORM)
    [COND
      ((EQ (CAR FORM)
           (QUOTE STRUCFORM))
        (SETQ FORM (CDR FORM]
    (OR (GETD (CAR FORM))
        (ERROR (CAR FORM)
               "not a function" T))
    (RESETFORM (PRINTLEVEL 3)
               (SELECTQ (ARGTYPE (CAR FORM))
                        [(0 1)
                          (MAPC (ARGLIST (CAR FORM))
                                (FUNCTION (LAMBDA (X)
                                    (PRIN1 X T)
                                    (PRIN1 " = " T)
                                    (PRINT (CAR (SETQ FORM
                                                  (CDR FORM)))
                                           T]
                        (PROGN (PRIN1 (ARGLIST (CAR FORM))
                                      T)
                               (PRIN1 " = " T)
                               (PRINT (CDR FORM)
                                      T])
)
(DECLARE
  (BLOCK: GROUPRADBLOCK GROUPRADS GROUPRADS1 (ENTRIES GROUPRADS))
  (BLOCK: NIL CIELING GROUPBY CARLIST CDRLIST LCARLIST LCDRLIST 
          DELETE DIFF ORDPAIR MAX MIN ORDERED SUMOF LMASSOC 
          INTERSECTP ?= (LINKFNS . T))
) [ADDTOVAR USERMACROS [?= NIL (ORR ((E (?= (##))
                                        T))
                                    ((E (QUOTE ?=?]
            (?= NIL (ORR [(E (MAP2C (ARGLIST (## 1))
                                    (## 2 UP)
                                    (FUNCTION (LAMBDA (X Y)
                                                      (PRIN1 X T)
                                                      (PRIN1 " = " T)
                                                      (PRINT Y T]
                         ((E (QUOTE ?=?]
  (ADDTOVAR EDITCOMSA ?= ?=)
STOP